home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr11.lha / clx / depdefs.lisp < prev    next >
Lisp/Scheme  |  1992-06-08  |  23KB  |  681 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
  2.  
  3. ;; This file contains some of the system dependent code for CLX
  4.  
  5. ;;;
  6. ;;;             TEXAS INSTRUMENTS INCORPORATED
  7. ;;;                  P.O. BOX 2909
  8. ;;;                   AUSTIN, TEXAS 78769
  9. ;;;
  10. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  11. ;;;
  12. ;;; Permission is granted to any individual or institution to use, copy, modify,
  13. ;;; and distribute this software, provided that this complete copyright and
  14. ;;; permission notice is maintained, intact, in all copies and supporting
  15. ;;; documentation.
  16. ;;;
  17. ;;; Texas Instruments Incorporated provides this software "as is" without
  18. ;;; express or implied warranty.
  19. ;;;
  20.  
  21. (in-package :xlib)
  22.  
  23. #+cmu
  24. (eval-when (compile load eval)
  25.   (let ((vs (lisp-implementation-version)))
  26.     (when (and (<= 2 (length vs))
  27.            (eql #\1 (aref vs 0))
  28.            (let ((d (digit-char-p (aref vs 1))))
  29.          (and d (<= 6 d))))
  30.       (pushnew :cmu16 *features*))))
  31.  
  32. ;;;-------------------------------------------------------------------------
  33. ;;; Declarations
  34. ;;;-------------------------------------------------------------------------
  35.  
  36. ;;; fix a bug in kcl's RATIONAL...
  37. ;;;   redefine both the function and the type.
  38.  
  39. #+(or kcl ibcl)
  40. (progn
  41.   (defun rational (x)
  42.     (if (rationalp x)
  43.     x
  44.     (lisp:rational x)))
  45.   (deftype rational (&optional l u) `(lisp:rational ,l ,u)))
  46.  
  47. ;;; DECLAIM
  48.  
  49. #-clx-ansi-common-lisp
  50. (defmacro declaim (&rest decl-specs)
  51.   (if (cdr decl-specs)
  52.       `(progn
  53.      ,@(mapcar #'(lambda (decl-spec) `(proclaim ',decl-spec))
  54.            decl-specs))
  55.     `(proclaim ',(car decl-specs))))
  56.  
  57. ;;; VALUES value1 value2 ... -- Documents the values returned by the function.
  58.  
  59. #-lispm
  60. (declaim (declaration values))
  61.  
  62. ;;; ARGLIST arg1 arg2 ... -- Documents the arglist of the function.  Overrides
  63. ;;; the documentation that might get generated by the real arglist of the
  64. ;;; function.
  65.  
  66. #-(or lispm lcl3.0)
  67. (declaim (declaration arglist))
  68.  
  69. ;;; DYNAMIC-EXTENT var -- Tells the compiler that the rest arg var has
  70. ;;; dynamic extent and therefore can be kept on the stack and not copied to
  71. ;;; the heap, even though the value is passed out of the function.
  72.  
  73. #-(or clx-ansi-common-lisp lcl3.0)
  74. (declaim (declaration dynamic-extent))
  75.  
  76. ;;; IGNORABLE var -- Tells the compiler that the variable might or might not be used.
  77.  
  78. #-clx-ansi-common-lisp
  79. (declaim (declaration ignorable))
  80.  
  81. ;;; ARRAY-REGISTER var1 var2 ... -- The variables mentioned are locals (not
  82. ;;; args) that hold vectors.  
  83.  
  84. #-Genera 
  85. (declaim (declaration array-register))
  86.  
  87. ;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to
  88. ;;; indent calls to the function or macro containing the declaration.  
  89.  
  90. #-genera
  91. (declaim (declaration indentation))
  92.  
  93. ;;;-------------------------------------------------------------------------
  94. ;;; Declaration macros
  95. ;;;-------------------------------------------------------------------------
  96.  
  97. ;;; WITH-VECTOR (variable type) &body body --- ensures the variable is a local
  98. ;;; and then does a type declaration and array register declaration
  99. (defmacro with-vector ((var type) &body body)
  100.   `(let ((,var ,var))
  101.      (declare (type ,type ,var)
  102.           (array-register ,var))
  103.      ,@body))
  104.  
  105. ;;; WITHIN-DEFINITION (name type) &body body --- Includes definitions for
  106. ;;; Meta-.
  107.  
  108. #+lispm
  109. (defmacro within-definition ((name type) &body body)
  110.   `(zl:local-declare
  111.      ((sys:function-parent ,name ,type))
  112.      (sys:record-source-file-name ',name ',type)
  113.      ,@body))
  114.  
  115. #-lispm
  116. (defmacro within-definition ((name type) &body body)
  117.   (declare (ignore name type))
  118.   `(progn ,@body))
  119.  
  120.  
  121. ;;;-------------------------------------------------------------------------
  122. ;;; CLX can maintain a mapping from X server ID's to local data types.  If
  123. ;;; one takes the view that CLX objects will be instance variables of
  124. ;;; objects at the next higher level, then PROCESS-EVENT will typically map
  125. ;;; from resource-id to higher-level object.  In that case, the lower-level
  126. ;;; CLX mapping will almost never be used (except in rare cases like
  127. ;;; query-tree), and only serve to consume space (which is difficult to
  128. ;;; GC), in which case always-consing versions of the make-<mumble>s will
  129. ;;; be better.  Even when maps are maintained, it isn't clear they are
  130. ;;; useful for much beyond xatoms and windows (since almost nothing else
  131. ;;; ever comes back in events).
  132. ;;;--------------------------------------------------------------------------
  133. (defconstant *clx-cached-types*
  134.          '( drawable
  135.         window
  136.         pixmap
  137. ;        gcontext
  138.         cursor
  139.         colormap
  140.         font))
  141.  
  142. (defmacro resource-id-map-test ()
  143.   #+excl '#'equal
  144.   #-excl '#'eql)
  145.                     ; (eq fixnum fixnum) is not guaranteed.
  146. (defmacro atom-cache-map-test ()
  147.   #+excl '#'equal
  148.   #-excl '#'eq)
  149.  
  150. (defmacro keysym->character-map-test ()
  151.   #+excl '#'equal
  152.   #-excl '#'eql)
  153.  
  154. ;;; You must define this to match the real byte order.  It is used by
  155. ;;; overlapping array and image code.
  156.  
  157. #+(or lispm vax little-endian Minima)
  158. (eval-when (eval compile load)
  159.   (pushnew :clx-little-endian *features*))
  160.  
  161. #+lcl3.0
  162. (eval-when (compile eval load)
  163.   (ecase lucid::machine-endian
  164.     (:big nil)
  165.     (:little (pushnew :clx-little-endian *features*))))
  166.  
  167. #+cmu
  168. (eval-when (compile eval load)
  169.   (ecase #.(c:backend-byte-order c:*backend*)
  170.     (:big-endian)
  171.     (:little-endian (pushnew :clx-little-endian *features*))))
  172.  
  173. ;;; Steele's Common-Lisp states:  "It is an error if the array specified
  174. ;;; as the :displaced-to argument  does not have the same :element-type
  175. ;;; as the array being created" If this is the case on your lisp, then
  176. ;;; leave the overlapping-arrays feature turned off.  Lisp machines
  177. ;;; (Symbolics TI and LMI) don't have this restriction, and allow arrays
  178. ;;; with different element types to overlap.  CLX will take advantage of
  179. ;;; this to do fast array packing/unpacking when the overlapping-arrays
  180. ;;; feature is enabled.
  181.  
  182. #+(and clx-little-endian lispm)
  183. (eval-when (eval compile load)
  184.   (pushnew :clx-overlapping-arrays *features*))
  185.  
  186. #+(and clx-overlapping-arrays genera)
  187. (progn
  188. (deftype overlap16 () '(unsigned-byte 16))
  189. (deftype overlap32 () '(signed-byte 32))
  190. )
  191.  
  192. #+(and clx-overlapping-arrays (or explorer lambda cadr))
  193. (progn
  194. (deftype overlap16 () '(unsigned-byte 16))
  195. (deftype overlap32 () '(unsigned-byte 32))
  196. )
  197.  
  198. (deftype buffer-bytes () `(simple-array (unsigned-byte 8) (*)))
  199.  
  200. #+clx-overlapping-arrays
  201. (progn
  202. (deftype buffer-words () `(vector overlap16))
  203. (deftype buffer-longs () `(vector overlap32))
  204. )
  205.  
  206. ;;; This defines a type which is a subtype of the integers.
  207. ;;; This type is used to describe all variables that can be array indices.
  208. ;;; It is here because it is used below.
  209. ;;; This is inclusive because start/end can be 1 past the end.
  210. (deftype array-index () `(integer 0 ,array-dimension-limit))
  211.  
  212.  
  213. ;; this is the best place to define these?
  214.  
  215. #-Genera
  216. (progn
  217.  
  218. (defun make-index-typed (form)
  219.   (if (constantp form) form `(the array-index ,form)))
  220.  
  221. (defun make-index-op (operator args)
  222.   `(the array-index
  223.     (values 
  224.       ,(case (length args)
  225.          (0 `(,operator))
  226.          (1 `(,operator
  227.           ,(make-index-typed (first args))))
  228.          (2 `(,operator
  229.           ,(make-index-typed (first args))
  230.           ,(make-index-typed (second args))))
  231.          (otherwise
  232.            `(,operator
  233.          ,(make-index-op operator (subseq args 0 (1- (length args))))
  234.          ,(make-index-typed (first (last args)))))))))
  235.  
  236. (defmacro index+ (&rest numbers) (make-index-op '+ numbers))
  237. (defmacro index-logand (&rest numbers) (make-index-op 'logand numbers))
  238. (defmacro index-logior (&rest numbers) (make-index-op 'logior numbers))
  239. (defmacro index- (&rest numbers) (make-index-op '- numbers))
  240. (defmacro index* (&rest numbers) (make-index-op '* numbers))
  241.  
  242. (defmacro index1+ (number) (make-index-op '1+ (list number)))
  243. (defmacro index1- (number) (make-index-op '1- (list number)))
  244.  
  245. (defmacro index-incf (place &optional (delta 1))
  246.   (make-index-op 'incf (list place delta)))
  247. (defmacro index-decf (place &optional (delta 1))
  248.   (make-index-op 'decf (list place delta)))
  249.  
  250. (defmacro index-min (&rest numbers) (make-index-op 'min numbers))
  251. (defmacro index-max (&rest numbers) (make-index-op 'max numbers))
  252.  
  253. (defmacro index-floor (number divisor)
  254.   (make-index-op 'floor (list number divisor)))
  255. (defmacro index-ceiling (number divisor)
  256.   (make-index-op 'ceiling (list number divisor)))
  257. (defmacro index-truncate (number divisor)
  258.   (make-index-op 'truncate (list number divisor)))
  259.  
  260. (defmacro index-mod (number divisor)
  261.   (make-index-op 'mod (list number divisor)))
  262.  
  263. (defmacro index-ash (number count)
  264.   (make-index-op 'ash (list number count)))
  265.  
  266. (defmacro index-plusp (number) `(plusp (the array-index ,number)))
  267. (defmacro index-zerop (number) `(zerop (the array-index ,number)))
  268. (defmacro index-evenp (number) `(evenp (the array-index ,number)))
  269. (defmacro index-oddp  (number) `(oddp  (the array-index ,number)))
  270.  
  271. (defmacro index> (&rest numbers)
  272.   `(> ,@(mapcar #'make-index-typed numbers)))
  273. (defmacro index= (&rest numbers)
  274.   `(= ,@(mapcar #'make-index-typed numbers)))
  275. (defmacro index< (&rest numbers)
  276.   `(< ,@(mapcar #'make-index-typed numbers)))
  277. (defmacro index>= (&rest numbers)
  278.   `(>= ,@(mapcar #'make-index-typed numbers)))
  279. (defmacro index<= (&rest numbers)
  280.   `(<= ,@(mapcar #'make-index-typed numbers)))
  281.  
  282. )
  283.  
  284. #+Genera
  285. (progn
  286.  
  287. (defmacro index+ (&rest numbers) `(+ ,@numbers))
  288. (defmacro index-logand (&rest numbers) `(logand ,@numbers))
  289. (defmacro index-logior (&rest numbers) `(logior ,@numbers))
  290. (defmacro index- (&rest numbers) `(- ,@numbers))
  291. (defmacro index* (&rest numbers) `(* ,@numbers))
  292.  
  293. (defmacro index1+ (number) `(1+ ,number))
  294. (defmacro index1- (number) `(1- ,number))
  295.  
  296. (defmacro index-incf (place &optional (delta 1)) `(setf ,place (index+ ,place ,delta)))
  297. (defmacro index-decf (place &optional (delta 1)) `(setf ,place (index- ,place ,delta)))
  298.  
  299. (defmacro index-min (&rest numbers) `(min ,@numbers))
  300. (defmacro index-max (&rest numbers) `(max ,@numbers))
  301.  
  302. (defun positive-power-of-two-p (x)
  303.   (when (symbolp x)
  304.     (multiple-value-bind (constantp value) (lt:named-constant-p x)
  305.       (when constantp (setq x value))))
  306.   (and (typep x 'fixnum) (plusp x) (zerop (logand x (1- x)))))
  307.  
  308. (defmacro index-floor (number divisor)
  309.   (cond ((eql divisor 1) number)
  310.     ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor))
  311.      `(si:%fixnum-floor ,number ,divisor))
  312.     (t `(floor ,number ,divisor))))
  313.  
  314. (defmacro index-ceiling (number divisor)
  315.   (cond ((eql divisor 1) number)
  316.     ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-ceiling))
  317.      `(si:%fixnum-ceiling ,number ,divisor))
  318.     (t `(ceiling ,number ,divisor))))
  319.  
  320. (defmacro index-truncate (number divisor)
  321.   (cond ((eql divisor 1) number)
  322.     ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor))
  323.      `(si:%fixnum-floor ,number ,divisor))
  324.     (t `(truncate ,number ,divisor))))
  325.  
  326. (defmacro index-mod (number divisor)
  327.   (cond ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-mod))
  328.      `(si:%fixnum-mod ,number ,divisor))
  329.     (t `(mod ,number ,divisor))))
  330.  
  331. (defmacro index-ash (number count)
  332.   (cond ((eql count 0) number)
  333.     ((and (typep count 'fixnum) (minusp count) (fboundp 'si:%fixnum-floor))
  334.      `(si:%fixnum-floor ,number ,(expt 2 (- count))))
  335.     ((and (typep count 'fixnum) (plusp count) (fboundp 'si:%fixnum-multiply))
  336.      `(si:%fixnum-multiply ,number ,(expt 2 count)))
  337.     (t `(ash ,number ,count))))
  338.  
  339. (defmacro index-plusp (number) `(plusp ,number))
  340. (defmacro index-zerop (number) `(zerop ,number))
  341. (defmacro index-evenp (number) `(evenp ,number))
  342. (defmacro index-oddp  (number) `(oddp  ,number))
  343.  
  344. (defmacro index> (&rest numbers) `(> ,@numbers))
  345. (defmacro index= (&rest numbers) `(= ,@numbers))
  346. (defmacro index< (&rest numbers) `(< ,@numbers))
  347. (defmacro index>= (&rest numbers) `(>= ,@numbers))
  348. (defmacro index<= (&rest numbers) `(<= ,@numbers))
  349.  
  350. )
  351.  
  352. ;;;; Stuff for BUFFER definition
  353.  
  354. (defconstant *replysize* 32.)
  355.  
  356. ;; used in defstruct initializations to avoid compiler warnings
  357. (defvar *empty-bytes* (make-sequence 'buffer-bytes 0))
  358. (declaim (type buffer-bytes *empty-bytes*))
  359. #+clx-overlapping-arrays
  360. (progn
  361. (defvar *empty-words* (make-sequence 'buffer-words 0))
  362. (declaim (type buffer-words *empty-words*))
  363. )
  364. #+clx-overlapping-arrays
  365. (progn
  366. (defvar *empty-longs* (make-sequence 'buffer-longs 0))
  367. (declaim (type buffer-longs *empty-longs*))
  368. )
  369.  
  370. (defstruct (reply-buffer (:conc-name reply-) (:constructor make-reply-buffer-internal)
  371.              (:copier nil) (:predicate nil))
  372.   (size 0 :type array-index)            ;Buffer size
  373.   ;; Byte (8 bit) input buffer
  374.   (ibuf8 *empty-bytes* :type buffer-bytes)
  375.   ;; Word (16bit) input buffer
  376.   #+clx-overlapping-arrays
  377.   (ibuf16 *empty-words* :type buffer-words)
  378.   ;; Long (32bit) input buffer
  379.   #+clx-overlapping-arrays
  380.   (ibuf32 *empty-longs* :type buffer-longs)
  381.   (next nil #-explorer :type #-explorer (or null reply-buffer))
  382.   (data-size 0 :type array-index)
  383.   )
  384.  
  385. (defconstant *buffer-text16-size* 256)
  386. (deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,*buffer-text16-size*)))
  387.  
  388. ;; These are here because.
  389.  
  390. (defparameter *xlib-package* (find-package :xlib))
  391.  
  392. (defun xintern (&rest parts)
  393.   (intern (apply #'concatenate 'string (mapcar #'string parts)) *xlib-package*))
  394.  
  395. (defparameter *keyword-package* (find-package :keyword))
  396.  
  397. (defun kintern (name)
  398.   (intern (string name) *keyword-package*))
  399.  
  400. ;;; Pseudo-class mechanism.
  401.  
  402. (eval-when (eval compile load)
  403. (defvar *def-clx-class-use-defclass* #+Genera t #-Genera nil
  404.   "Controls whether DEF-CLX-CLASS uses DEFCLASS.  
  405.    If it is a list, it is interpreted by DEF-CLX-CLASS to be a list of type names
  406.    for which DEFCLASS should be used. 
  407.    If it is not a list, then DEFCLASS is always used.
  408.    If it is NIL, then DEFCLASS is never used, since NIL is the empty list.")
  409.  
  410. ;;************
  411. (setq *def-clx-class-use-defclass* '(window drawable pixmap))
  412. #+pcl (setq pcl::*defclass-times*   '(compile load eval))
  413. )
  414.  
  415. (defmacro def-clx-class ((name &rest options) &body slots)
  416.   (if (or (not (listp *def-clx-class-use-defclass*))
  417.       (member name *def-clx-class-use-defclass*))
  418.       (let ((clos-package #+clx-ansi-common-lisp
  419.               (find-package :common-lisp)
  420.               #-clx-ansi-common-lisp
  421.               (or (find-package :pcl) ; *** switched ***
  422.                   (find-package :clos)
  423.                   (let ((lisp-pkg (find-package :lisp)))
  424.                 (and (find-symbol (string 'defclass) lisp-pkg)
  425.                      lisp-pkg))))
  426.         (constructor t)
  427.         (constructor-args t)
  428.         (include nil)
  429.         (print-function nil)
  430.         (copier t)
  431.         (predicate t))
  432.     (dolist (option options)
  433.       (ecase (pop option)
  434.         (:constructor
  435.           (setf constructor (pop option))
  436.           (setf constructor-args (if (null option) t (pop option))))
  437.         (:include
  438.           (setf include (pop option)))
  439.         (:print-function
  440.           (setf print-function (pop option)))
  441.         (:copier
  442.           (setf copier (pop option)))
  443.         (:predicate
  444.           (setf predicate (pop option)))))
  445.     (flet ((cintern (&rest symbols)
  446.          (intern (apply #'concatenate 'simple-string
  447.                 (mapcar #'symbol-name symbols))
  448.              *package*))
  449.            (kintern (symbol)
  450.             (intern (symbol-name symbol) (find-package :keyword)))
  451.            (closintern (symbol)
  452.          (intern (symbol-name symbol) clos-package)))
  453.       (when (eq constructor t)
  454.         (setf constructor (cintern 'make- name)))
  455.       (when (eq copier t)
  456.         (setf copier (cintern 'copy- name)))
  457.       (when (eq predicate t)
  458.         (setf predicate (cintern name '-p)))
  459.       (when include
  460.         (setf slots (append (get include 'def-clx-class) slots)))
  461.       (let* ((n-slots (length slots))
  462.          (slot-names (make-list n-slots))
  463.          (slot-initforms (make-list n-slots))
  464.          (slot-types (make-list n-slots)))
  465.         (dotimes (i n-slots)
  466.           (let ((slot (elt slots i)))
  467.         (setf (elt slot-names i) (pop slot))
  468.         (setf (elt slot-initforms i) (pop slot))
  469.         (setf (elt slot-types i) (getf slot :type t))))
  470.         `(progn
  471.  
  472.            (eval-when (compile load eval)
  473.          (setf (get ',name 'def-clx-class) ',slots))
  474.  
  475.            ;; From here down are the system-specific expansions:
  476.  
  477.            (within-definition (,name def-clx-class)
  478.          (,(closintern 'defclass)
  479.           ,name ,(and include `(,include))
  480.           (,@(map 'list
  481.               #'(lambda (slot-name slot-initform slot-type)
  482.                   `(,slot-name
  483.                 :initform ,slot-initform :type ,slot-type
  484.                 :accessor ,(cintern name '- slot-name)
  485.                 ,@(when (and constructor
  486.                          (or (eq constructor-args t)
  487.                          (member slot-name
  488.                              constructor-args)))
  489.                     `(:initarg ,(kintern slot-name)))
  490.                 ))
  491.               slot-names slot-initforms slot-types)))
  492.          ,(when constructor
  493.             (if (eq constructor-args t)
  494.             `(defun ,constructor (&rest args)
  495.                (apply #',(closintern 'make-instance)
  496.                   ',name args))
  497.             `(defun ,constructor ,constructor-args
  498.                (,(closintern 'make-instance) ',name
  499.                 ,@(mapcan #'(lambda (slot-name)
  500.                       (and (member slot-name slot-names)
  501.                            `(,(kintern slot-name) ,slot-name)))
  502.                       constructor-args)))))
  503.          ,(when predicate
  504.             #+(or allegro pcl)
  505.             `(progn
  506.                (,(closintern 'defmethod) ,predicate (object)
  507.              (declare (ignore object))
  508.              nil)
  509.                (,(closintern 'defmethod) ,predicate ((object ,name))
  510.              t))
  511.             #-(or allegro pcl)
  512.             `(defun ,predicate (object)
  513.                (typep object ',name)))
  514.          ,(when copier
  515.             `(,(closintern 'defmethod) ,copier ((.object. ,name))
  516.               (,(closintern 'with-slots) ,slot-names .object.
  517.                (,(closintern 'make-instance) ',name
  518.             ,@(mapcan #'(lambda (slot-name)
  519.                       `(,(kintern slot-name) ,slot-name))
  520.                   slot-names)))))
  521.          ,(when print-function
  522.             `(,(closintern 'defmethod)
  523.               ,(closintern 'print-object)
  524.               ((object ,name) stream)
  525.               (,print-function object stream 0))))))))
  526.       `(within-definition (,name def-clx-class)
  527.      (defstruct (,name ,@options)
  528.        ,@slots))))
  529.  
  530. #+Genera
  531. (progn
  532.   (scl:defprop def-clx-class "CLX Class" si:definition-type-name)
  533.   (scl:defprop def-clx-class zwei:defselect-function-spec-finder
  534.            zwei:definition-function-spec-finder))
  535.  
  536.  
  537. ;; We need this here so we can define DISPLAY for CLX.
  538. ;;
  539. ;; This structure is :INCLUDEd in the DISPLAY structure.
  540. ;; Overlapping (displaced) arrays are provided for byte
  541. ;; half-word and word access on both input and output.
  542. ;;
  543. (def-clx-class (buffer (:constructor nil) (:copier nil) (:predicate nil))
  544.   ;; Lock for multi-processing systems
  545.   (lock (make-process-lock "CLX Buffer Lock"))
  546.   #-excl (output-stream nil :type (or null stream))
  547.   #+excl (output-stream -1 :type fixnum)
  548.   ;; Buffer size
  549.   (size 0 :type array-index)
  550.   (request-number 0 :type (unsigned-byte 16))
  551.   ;; Byte position of start of last request
  552.   ;; used for appending requests and error recovery
  553.   (last-request nil :type (or null array-index))
  554.   ;; Byte position of start of last flushed request
  555.   (last-flushed-request nil :type (or null array-index))
  556.   ;; Current byte offset
  557.   (boffset 0 :type array-index)
  558.   ;; Byte (8 bit) output buffer
  559.   (obuf8 *empty-bytes* :type buffer-bytes)
  560.   ;; Word (16bit) output buffer
  561.   #+clx-overlapping-arrays
  562.   (obuf16 *empty-words* :type buffer-words)
  563.   ;; Long (32bit) output buffer
  564.   #+clx-overlapping-arrays
  565.   (obuf32 *empty-longs* :type buffer-longs)
  566.   ;; Holding buffer for 16-bit text
  567.   (tbuf16 (make-sequence 'buffer-text16 *buffer-text16-size* :initial-element 0))
  568.   ;; Probably EQ to Output-Stream
  569.   #-excl (input-stream nil :type (or null stream))
  570.   #+excl (input-stream -1 :type fixnum)
  571.   ;; T when the host connection has gotten errors
  572.   (dead nil :type (or null (not null)))
  573.   ;; T makes buffer-flush a noop.  Manipulated with with-buffer-flush-inhibited.
  574.   (flush-inhibit nil :type (or null (not null)))
  575.   
  576.   ;; Change these functions when using shared memory buffers to the server
  577.   ;; Function to call when writing the buffer
  578.   (write-function 'buffer-write-default)
  579.   ;; Function to call when flushing the buffer
  580.   (force-output-function 'buffer-force-output-default)
  581.   ;; Function to call when closing a connection
  582.   (close-function 'buffer-close-default)
  583.   ;; Function to call when reading the buffer
  584.   (input-function 'buffer-read-default)
  585.   ;; Function to call to wait for data to be input
  586.   (input-wait-function 'buffer-input-wait-default)
  587.   ;; Function to call to listen for input data
  588.   (listen-function 'buffer-listen-default)
  589.  
  590.   #+Genera (debug-io nil :type (or null stream))
  591.   ) 
  592.  
  593. ;;-----------------------------------------------------------------------------
  594. ;; Printing routines.
  595. ;;-----------------------------------------------------------------------------
  596.  
  597. #-(or clx-ansi-common-lisp Genera CMU)
  598. (defun print-unreadable-object-function (object stream type identity function)
  599.   (declare #+lispm
  600.        (sys:downward-funarg function))
  601.   (princ "#<" stream)
  602.   (when type
  603.     (let ((type (type-of object))
  604.       (pcl-package (find-package :pcl)))
  605.       ;; Handle pcl type-of lossage
  606.       (when (and pcl-package
  607.          (symbolp type)
  608.          (eq (symbol-package type) pcl-package)
  609.          (string-equal (symbol-name type) "STD-INSTANCE"))
  610.     (setq type
  611.           (funcall (intern (symbol-name 'class-name) pcl-package)
  612.                (funcall (intern (symbol-name 'class-of) pcl-package)
  613.                 object))))
  614.       (prin1 type stream)))
  615.   (when (and type function) (princ " " stream))
  616.   (when function (funcall function))
  617.   (when (and (or type function) identity) (princ " " stream))
  618.   (when identity (princ "???" stream))
  619.   (princ ">" stream)
  620.   nil)
  621.   
  622. #-(or clx-ansi-common-lisp Genera CMU)
  623. (defmacro print-unreadable-object
  624.       ((object stream &key type identity) &body body)
  625.   (if body
  626.       `(flet ((.print-unreadable-object-body. () ,@body))
  627.      (print-unreadable-object-function
  628.        ,object ,stream ,type ,identity #'.print-unreadable-object-body.))
  629.     `(print-unreadable-object-function ,object ,stream ,type ,identity nil)))
  630.  
  631.  
  632. ;;-----------------------------------------------------------------------------
  633. ;; Image stuff
  634. ;;-----------------------------------------------------------------------------
  635.  
  636. (defconstant *image-bit-lsb-first-p*
  637.          #+clx-little-endian t
  638.          #-clx-little-endian nil)
  639.  
  640. (defconstant *image-byte-lsb-first-p*
  641.          #+clx-little-endian t
  642.          #-clx-little-endian nil)
  643.  
  644. (defconstant *image-unit* 32)
  645.  
  646. (defconstant *image-pad* 32)
  647.  
  648.  
  649. ;;-----------------------------------------------------------------------------
  650. ;; Foreign Functions
  651. ;;-----------------------------------------------------------------------------
  652.  
  653. #+(and lucid apollo (not lcl3.0))
  654. (lucid::define-foreign-function '(connect-to-server "connect_to_server")
  655.   '((:val host    :string)
  656.     (:val display :integer32))
  657.   :integer32)
  658.  
  659. #+(and lucid (not apollo) (not lcl3.0))
  660. (lucid::define-c-function connect-to-server (host display)
  661.   :result-type :integer)
  662.  
  663. #+lcl3.0
  664. (lucid::def-foreign-function
  665.     (connect-to-server 
  666.       (:language :c)
  667.       (:return-type :signed-32bit))
  668.   (host :simple-string)
  669.   (display :signed-32bit))
  670.  
  671. #+(and CMU (not cmu16))
  672. (ext:def-c-routine ("connect_to_server" connect-to-server) (ext:int)
  673.   (host system:null-terminated-string)
  674.   (port ext:int))
  675.  
  676. #+cmu16
  677. (alien:def-alien-routine ("connect_to_server" xlib::connect-to-server)
  678.                c-call:int
  679.     (host c-call:c-string)
  680.     (port c-call:int))
  681.